home *** CD-ROM | disk | FTP | other *** search
/ Cream of the Crop 1 / Cream of the Crop 1.iso / PROGRAM / EXTEND5.ARJ / SHRINK.PAS < prev   
Pascal/Delphi Source File  |  1991-02-27  |  5KB  |  134 lines
  1. unit Shrink;
  2.  
  3. { This unit allows you to allocate memory from the DOS memory pool rather than
  4.   from the Turbo Pascal heap.  It also provides a procedure for shrinking the
  5.   current program to free up DOS memory.
  6.  
  7.   Scott Bussinger
  8.   Professional Practice Systems
  9.   110 South 131st Street
  10.   Tacoma, WA  98444
  11.   (206)531-8944
  12.   Compuserve [72247,2671] }
  13.  
  14. { ** Revision History **
  15.   1 SHRINK.PAS 15-Sep-89,`SCOTT' Initial version of SHRINK unit
  16.   2 SHRINK.PAS 19-Oct-90,`SCOTT'
  17.            Added support for Turbo Pascal 6's new heap manager
  18.   3 SHRINK.PAS 27-Feb-91,`SCOTT'
  19.            Fixed problem in allocating memory in Turbo Pascal 6.0
  20.            Fixed missing variable for compilers prior to Turbo Pascal 6.0
  21.   ** Revision History ** }
  22.  
  23. interface
  24.  
  25. procedure DosNew(var P: pointer;
  26.                      Bytes: word);
  27.   { Get a pointer to a chunk of memory from DOS.  Returns NIL if
  28.     sufficient DOS memory is not available. }
  29.  
  30. procedure DosDispose(var P: pointer);
  31.   { Return an allocated chunk of memory to DOS.  Only call this function
  32.     with pointers allocated with DosNew or DosNewShrink. }
  33.  
  34. procedure DosNewShrink(var P: pointer;
  35.                            Bytes: word);
  36.   { Get a pointer to a chunk of memory from DOS, shrinking current program
  37.     to gain DOS memory if necessary.  Returns NIL if sufficient DOS memory
  38.     is not available and there is insufficient free space in the heap to
  39.     allow program to be shrunk to accomodate the request. }
  40.  
  41. implementation
  42.  
  43. uses Dos;
  44.  
  45. const DosOverhead = 1;                           { Extra number of paragraphs that DOS requires in overhead for MCB chain }
  46.  
  47. function Linear(P: pointer): longint;
  48.   { Return the pointer as a linear longint value }
  49.   begin
  50.   Linear := (longint(seg(P^)) shl 4) + ofs(P^)
  51.   end;
  52.  
  53. procedure DosNew(var P: pointer;
  54.                      Bytes: word);
  55.   { Get a pointer to a chunk of memory from DOS.  Returns NIL if
  56.     sufficient DOS memory is not available. }
  57.   var SegsToAllocate: word;
  58.       Regs: Registers;
  59.   begin
  60.   SegsToAllocate := (Bytes+15) shr 4;            { DOS allocates memory in paragraph sized pieces only }
  61.   with Regs do
  62.     begin
  63.     AH := $48;
  64.     BX := SegsToAllocate;
  65.     MsDos(Regs);
  66.     if odd(Flags)
  67.      then
  68.       P := nil                                   { No memory available }
  69.      else
  70.       P := ptr(AX,$0000)                         { Return pointer to memory block }
  71.     end
  72.   end;
  73.  
  74. procedure DosDispose(var P: pointer);
  75.   { Return an allocated chunk of memory to DOS.  Only call this function
  76.     with pointers allocated with DosNew or DosNewShrink. }
  77.   var Regs: Registers;
  78.   begin
  79.   with Regs do
  80.     begin
  81.     AH := $49;
  82.     ES := seg(P^);
  83.     MsDos(Regs)
  84.     end
  85.   end;
  86.  
  87. procedure DosNewShrink(var P: pointer;
  88.                            Bytes: word);
  89.   { Get a pointer to a chunk of memory from DOS, shrinking current program
  90.     to gain DOS memory if necessary.  Returns NIL if sufficient DOS memory
  91.     is not available and there is insufficient free space in the heap to
  92.     allow program to be shrunk to accomodate the request. }
  93.   var BytesToAllocate: word;
  94.       OldFreePtr: pointer;
  95.       Regs: Registers;
  96.   begin
  97.   BytesToAllocate := (((Bytes+15) shr 4) + DosOverhead) shl 4;
  98.   DosNew(P,Bytes);                               { Try to get memory the easy way first }
  99.   {$IFDEF VER60}                                 { Check for Turbo 6's new heap manager }
  100.   if (P=nil) and (Linear(HeapEnd)-Linear(HeapPtr)>=BytesToAllocate) then
  101.     begin                                        { The easy method didn't work but there is sufficient space in the heap }
  102.     dec(longint(HeapEnd),longint(BytesToAllocate) shl 12); { Move the top of the heap down }
  103.     with Regs do
  104.       begin
  105.       AH := $4A;
  106.       BX := seg(HeapEnd^) - prefixseg;
  107.       ES := prefixseg;
  108.       MsDos(Regs)
  109.       end;
  110.     DosNew(P,Bytes)                              { Try the DOS allocation one more time }
  111.     end
  112.   {$ELSE}
  113.   if (P=nil) and                                 { Handle the old free list style heap }
  114.      (((ofs(FreePtr^)=0) and (Linear(FreePtr)+$10000-Linear(HeapPtr)>=BytesToAllocate)) or
  115.       ((ofs(FreePtr^)<>0) and (Linear(FreePtr)-Linear(HeapPtr)>=BytesToAllocate))) then
  116.     begin                                        { The easy method didn't work but there is sufficient space in the heap }
  117.     OldFreePtr := FreePtr;
  118.     dec(longint(FreePtr),longint(BytesToAllocate) shl 12); { Decrement the segment of the pointer to the free list }
  119.     if ofs(OldFreePtr^) <> 0 then                { If free list is empty, then there's nothing to move }
  120.       move(OldFreePtr^,FreePtr^,$10000-ofs(OldFreePtr^)); { Otherwise, move the free list down in memory }
  121.     with Regs do
  122.       begin
  123.       AH := $4A;
  124.       BX := seg(OldFreePtr^) + $1000 - prefixseg - (BytesToAllocate shr 4);
  125.       ES := prefixseg;
  126.       MsDos(Regs)
  127.       end;
  128.     DosNew(P,Bytes)                              { Try the DOS allocation one more time }
  129.     end
  130.   {$ENDIF}
  131.   end;
  132.  
  133. end.
  134.